﻿unit MVC.HttpMmt;

interface

uses
  System.DateUtils, SysUtils, Classes, IniFiles, Contnrs, SynCommons, SynCrtSock,
  Web.WebReq, Web.HTTPApp, MVC.Config, IdURI, SynZip, MVC.LogUnit,
  System.NetEncoding, Winapi.Windows;

type
 {$IF (CompilerVersion<20.0) OR (CompilerVersion>=30.0) }
  WBString = string;
{$ELSE}

  WBString = RawUTF8;
{$ENDIF}
{$IF CompilerVersion>33 }

  WBInt = Int64;
{$ELSE}

  WBInt = Integer;
{$ENDIF}

type
  TMethodType = (mtAny, mtGet, mtPut, mtPost, mtHead, mtDelete, mtPatch);

  THttpApi = class
  protected
    FContext: THttpServerRequest;
    FStatusCode: Integer;
    FMethod: WBString;
    FQueryString: WBString;
    FAnchor: WBString;
    FQueryFields: TStrings;
    FContentFields: TStrings;
    FRemoteIP: WBString;
    FPathInfo: WBString;
    FURL: WBString;
    FHost: WBString;
    function GetContentFields: TStrings;
    procedure processMultiPartFormData;
  public
    property Context: THttpServerRequest read FContext;
    property StatusCode: Integer read FStatusCode write FStatusCode;
    property Host: WBString read FHost;
    property Method: WBString read FMethod;
    property URL: WBString read FURL;
    property PathInfo: WBString read FPathInfo;
    property QueryString: WBString read FQueryString;
    property Anchor: WBString read FAnchor;
    property RemoteIP: WBString read FRemoteIP;
    property QueryFields: TStrings read FQueryFields;
    property ContentFields: TStrings read GetContentFields;
    //
    procedure OutHeader(const key, value: WBString);
    procedure OutStream(const AStream: TStream; const AContentType: WBString = '');
    procedure Redirect(const AURI: WBString);
    function GetHeader(const AUpKey: WBString): WBString;
    constructor Create(const vContext: THttpServerRequest);
    destructor Destroy; override;
  end;

  TCookie = class(TCollectionItem)
  private
    FName: WBString;
    FValue: WBString;
    FPath: WBString;
    FDomain: WBString;
    FExpires: TDateTime;
    FSecure: Boolean;
    FHttpOnly: Boolean;
    FSameSite: WBString;
  protected
    function GetHeaderValue: WBString;
  public
    constructor Create(Collection: TCollection); override;
    procedure AssignTo(Dest: TPersistent); override;
    property Name: WBString read FName write FName;
    property Value: WBString read FValue write FValue;
    property Domain: WBString read FDomain write FDomain;
    property Path: WBString read FPath write FPath;
    property Expires: TDateTime read FExpires write FExpires;
    property Secure: Boolean read FSecure write FSecure;
    property HeaderValue: WBString read GetHeaderValue;
    property HttpOnly: Boolean read FHttpOnly write FHttpOnly;
    property SameSite: WBString read FSameSite write FSameSite;
  end;

  TWebResponse = class;

  TCookieCollection = class(TCollection)
  private
    [weak]
    FWebResponse: TWebResponse;
  protected
    function GetCookie(Index: Integer): TCookie;
    procedure SetCookie(Index: Integer; Cookie: TCookie);
  public
    constructor Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
    function Add: TCookie;
    property WebResponse: TWebResponse read FWebResponse;
    property Items[Index: Integer]: TCookie read GetCookie write SetCookie; default;
  end;

  TAbstractWebRequestFile = class;

  TAbstractWebRequestFiles = class(TObject)
  protected
    FEnv: THttpApi;
    FParts: TMultiPartDynArray;
    FAbstractWebRequestFile: TAbstractWebRequestFile;
    function GetCount: Integer;
    function GetItem(I: Integer): TAbstractWebRequestFile;
  public
    property Items[I: Integer]: TAbstractWebRequestFile read GetItem; default;
    property Count: Integer read GetCount;
    constructor Create(const AEnv: THttpApi);
    destructor Destroy; override;
  end;

  TAbstractWebRequestFile = class(TObject)
  protected
    FStream: TMemoryStream;
    FAFile: TMultiPart;
    function GetFieldName: WBString;
    function GetFileName: WBString;
    function GetStream: TMemoryStream;
    function GetContentType: WBString;
  public
    property FieldName: WBString read GetFieldName;
    property FileName: WBString read GetFileName;
    property Stream: TMemoryStream read GetStream;
    property ContentType: WBString read GetContentType;
    procedure SetFile(AFile: TMultiPart);
    constructor Create();
    destructor Destroy; override;
  end;

  TWebRequest = class(TObject)
  private
    FEnv: THttpApi;
    FMethod: WBString;
    FPathInfo: WBString;
    FGetRemoteIP: WBString;
    FQueryString: WBString;
    FAnchor: WBString;
    FQueryFields: TStrings;
    FURL: WBString;
    FContentFields: TStrings;
    FContent: WBString;
    FAuthorization: WBString;
    FQuery: WBString;
    FMethodType: TMethodType;
    FCookieFields: TStrings;
    FAbstractWebRequestFiles: TAbstractWebRequestFiles;
    function GetCookieFields: TStrings;
    function GetFiles: TAbstractWebRequestFiles;
    function GetContentLength: WBInt;
    function GetUserAgent: WBString;
    function GetAccept: WBString;
    function GetHost: WBString;
    function GetAcceptEncoding: WBString;
    function GetAcceptLanguage: WBString;
    function GetConnection: WBString;
  public
    property Env: THttpApi read FEnv;
    property URL: WBString read FURL;
    property Method: WBString read FMethod;
    property PathInfo: WBString read FPathInfo;
    property QueryFields: TStrings read FQueryFields;
    property ContentFields: TStrings read FContentFields;
    property QueryString: WBString read FQueryString;
    property Anchor: WBString read FAnchor;
    property GetRemoteIP: WBString read FGetRemoteIP;
    property Content: WBString read FContent;
    property Authorization: WBString read FAuthorization;
    property Query: WBString read FQuery;
    property MethodType: TMethodType read FMethodType;
    property CookieFields: TStrings read GetCookieFields;
    property Files: TAbstractWebRequestFiles read GetFiles;
    property ContentLength: WBInt read GetContentLength;
    property UserAgent: WBString read GetUserAgent;
    property Accept: WBString read GetAccept;
    property Host: WBString read GetHost;
    property AcceptEncoding: WBString read GetAcceptEncoding;
    property AcceptLanguage: WBString read GetAcceptLanguage;
    property Connection: WBString read GetConnection;
    function GetHeader(const AUpKey: WBString): WBString;
    constructor Create(const AEnv: THttpApi);
    destructor Destroy; override;
  end;

  TWebResponse = class(TObject)
  private
    FSent: Boolean;
    FEnv: THttpApi;
    FContentType: WBString;
    FStatusCode: integer;
    FContent: WBString;
    FCustomHeaders: TStringList;
    FCookies: TCookieCollection;
    FContentEncoding: WBString;
    FDate: TDateTime;
    procedure SetContent(const Value: WBString);
    procedure SetContentType(const Value: WBString);
    procedure SetStatusCode(const Value: integer);
    procedure SetContentEncoding(const Value: WBString);
    procedure SetDate(const Value: TDateTime);
    procedure SetHeadValues;

  public
    property Sent: Boolean read FSent;
    property Env: THttpApi read FEnv;
    property Cookies: TCookieCollection read FCookies;
    property CustomHeaders: TStringList read FCustomHeaders;
    property StatusCode: integer read FStatusCode write SetStatusCode;
    property ContentType: WBString read FContentType write SetContentType;
    property Content: WBString read FContent write SetContent;
    property ContentEncoding: WBString read FContentEncoding write SetContentEncoding;
    property Date: TDateTime read FDate write SetDate;
    procedure SendResponse;
    procedure SendRedirect(const URI: WBString);
    procedure SendStream(AStream: TStream);
    procedure SetCustomHeader(key, value: WBString);
    constructor Create(HTTPRequest: TWebRequest);
    destructor Destroy; override;
  end;

  THTTPServer = class
  public
    HServer: THttpApiServer;
    Action: Boolean;
    procedure Start();
    procedure Stop();
    function Process(AContext: THttpServerRequest): cardinal;
    //
    constructor Create();
    destructor Destroy; override;
  end;

var
  httpServer: THTTPServer;

implementation

uses
  MVC.Route;

{ THttpServer }

constructor THTTPServer.Create;
begin
  if not Assigned(HServer) then
  begin
    HServer := THttpApiServer.Create(true);
    HServer.OnRequest := Process;
  end;
end;

destructor THTTPServer.Destroy;
begin
 // ExitProcess(0);
  if Assigned(HServer) then
  begin
    HServer.Free;
  end;
  inherited;
end;

function THTTPServer.Process(AContext: THttpServerRequest): cardinal;
var
  httpApi: THttpApi;
  request: TWebRequest;
  response: TWebResponse;
begin
  httpApi := THttpApi.Create(AContext);
  request := TWebRequest.Create(httpApi);
  response := TWebResponse.Create(request);
  try
    OpenRoute(request, response);
    Result := response.StatusCode;
  finally
    request.Free;
    response.Free;
    httpApi.Free;
  end;
end;

procedure THTTPServer.Start;
var
  compress: RawUTF8;
begin
  try
    compress := RawUTF8(Config.Compress);
    if UpperCase(compress) = UpperCase('deflate') then
      HServer.RegisterCompress(CompressDeflate)
    else if UpperCase(compress) = UpperCase('gzip') then
      HServer.RegisterCompress(CompressGZip);

    HServer.AddUrl('', RawUTF8(Config.Port), False, '+', false);
    HServer.HTTPQueueLength := Config.HTTPQueueLength;
    HServer.Clone(Config.ThreadCount);   //ChildThreadCount启动http监听线程
    HServer.Start;
    Action := true;
    if Action then
      log('服务启动')
    else
      log('服务启动失败，请使用管理员权限启动！' );
  except
    on e: Exception do
    begin
      log('服务启动失败:' + e.Message);
      {$IFDEF CONSOLE}
      Writeln('服务启动失败:' + e.Message);
      {$ENDIF}
    end;
  end;
end;

procedure THTTPServer.Stop;
begin
  HServer.RemoveUrl('', RawUTF8(config.Port), False, '+');
  log('服务停止');
end;

{ THttpApi }

constructor THttpApi.Create(const vContext: THttpServerRequest);
var
  nQPos, nAPos: Integer;
begin
  FStatusCode := 200;
  FContext := vContext;

  FQueryFields := TStringList.Create;
  FContentFields := TStringList.Create;
  FHost := WBString(GetHeader('HOST:'));
  FRemoteIP := (GetHeader('REMOTEIP:'));
  if (FRemoteIP = '') then
    FRemoteIP := UTF8ToString(FContext.RemoteIP);
  FMethod := WBString(FContext.Method);
  FURL := WBString(FContext.URL);
  nAPos := Pos('#', FURL);
  nQPos := Pos('?', FURL);
  if nQPos > 0 then
  begin
    FPathInfo := copy(FURL, 1, nQPos - 1);
    if nAPos > nQPos then
    begin
      FQueryString := copy(FURL, nQPos + 1, nAPos - nQPos - 1);
      FAnchor := copy(FURL, nAPos + 1, Length(FURL) - nAPos);
    end
    else
    begin
      FQueryString := copy(FURL, nQPos + 1, Length(FURL) - nQPos);
      FAnchor := '';
    end;
  end
  else
  begin
    FQueryString := '';
    if nAPos > 0 then
    begin
      FPathInfo := copy(FURL, 1, nAPos - 1);
      FAnchor := copy(FURL, nAPos + 1, Length(FURL) - nAPos);
    end
    else
    begin
      FPathInfo := FURL;
      FAnchor := '';
    end;
  end;
  FQueryFields.Text := UTF8ToString(StringReplaceAll(URLDecode(StringToUTF8(FQueryString)), '&', #13#10));
end;

destructor THttpApi.Destroy;
begin
  FQueryFields.Free;
  FContentFields.Free;
  inherited;
end;

function THttpApi.GetContentFields: TStrings;
begin
  if FContentFields.Count = 0 then
  begin
    if IdemPChar(PUTF8Char(FContext.InContentType), 'APPLICATION/X-WWW-FORM-URLENCODED') then
      FContentFields.Text := UTF8ToString(StringReplaceAll(URLDecode(FContext.InContent), '&', #13#10))
    else if IdemPChar(PUTF8Char(Context.InContentType), 'MULTIPART/FORM-DATA') then
      processMultiPartFormData;
  end;
  Result := FContentFields;
end;

function THttpApi.GetHeader(const AUpKey: WBString): WBString;
var
  text: WBString;
  headls: TStringList;
  key: WBString;
begin
  key := WBString(AUpKey);
  key := key.Replace(':', '');
  headls := TStringList.Create;
  try
    text := WBString(FContext.InHeaders);
    headls.Text := text.Replace(': ', '=');
    Result := WBString(headls.Values[key]);
  finally
    headls.Free;
  end;
end;

procedure THttpApi.OutHeader(const key, value: WBString);
begin
  if (Length(key) > 0) and (Length(value) > 0) then
  begin
    with FContext do
    begin
      if Length(OutCustomHeaders) > 0 then
        OutCustomHeaders := OutCustomHeaders + #13#10;

      OutCustomHeaders := OutCustomHeaders + StringToUTF8(key + ': ' + value);
    end;
  end;
end;

procedure THttpApi.OutStream(const AStream: TStream; const AContentType: WBString);
var
  Buffer: SockString;
begin

  SetLength(Buffer, AStream.Size);
  AStream.Position := 0;
  AStream.Read(Buffer[1], AStream.Size);
  Context.OutContent := Buffer;
  if Length(AContentType) > 0 then
    Context.OutContentType := StringToUTF8(AContentType);
end;

procedure THttpApi.processMultiPartFormData;
var
  FParts: TMultiPartDynArray;
  i: integer;
  ct: string;
  name, value: WBString;
begin
  MultiPartFormDataDecode(FContext.InContentType, FContext.InContent, FParts);
  for i := 0 to High(FParts) do
  begin
    name := UTF8ToString(FParts[i].name);
    ct := UTF8ToString(FParts[i].ContentType);
    if pos('text/plain', ct) > 0 then
      value := UTF8ToString(FParts[i].Content)
    else
      value := string(FParts[i].Content);

    FContentFields.Values[name] := value;
  end;
end;

procedure THttpApi.Redirect(const AURI: WBString);
begin
  OutHeader('Location', WBString(AURI));
  FStatusCode := 302;
end;

{ TRequest }

constructor TWebRequest.Create(const AEnv: THttpApi);
begin

  FEnv := AEnv;

  FMethod := FEnv.Method;
  if FMethod = 'Get' then
    FMethodType := mtGet
  else if FMethod = 'Post' then
    FMethodType := mtPost
  else if FMethod = 'Put' then
    FMethodType := mtPut
  else if FMethod = 'Head' then
    FMethodType := mtHead
  else if FMethod = 'Delete' then
    FMethodType := mtDelete
  else if FMethod = 'Patch' then
    FMethodType := mtPatch;
  FPathInfo := FEnv.PathInfo;
  FGetRemoteIP := FEnv.RemoteIP;
  FQueryString := FEnv.QueryString;
  FQueryFields := FEnv.QueryFields;
  FContentFields := FEnv.ContentFields;
  FContent := UTF8ToString(FEnv.Context.InContent);
  FURL := FEnv.URL;
  FQuery := QueryString;
  FAuthorization := FEnv.GetHeader('Authorization');
  GetCookieFields();
  FAbstractWebRequestFiles := TAbstractWebRequestFiles.Create(AEnv);
  inherited Create;
end;




{ TResponse }

constructor TWebResponse.Create(HTTPRequest: TWebRequest);
begin
  FCustomHeaders := TStringList.Create;
  FEnv := HTTPRequest.FEnv;
  FCookies := TCookieCollection.Create(Self, TCookie);
  FSent := False;
end;

destructor TWebResponse.Destroy;
begin
  FCustomHeaders.Free;
  FCookies.Free;
  inherited;
end;

procedure TWebResponse.SendRedirect(const URI: WBString);
begin
  Env.Redirect(URI);
  StatusCode := env.StatusCode;
  SendResponse();
end;

procedure TWebResponse.SetHeadValues();
var
  i: integer;
  cookie: WBString;
  date: string;
begin
  for i := 0 to Cookies.Count - 1 do
  begin
    cookie := Cookies[i].HeaderValue;
    Env.OutHeader(('Set-Cookie'), (cookie));
  end;
  for i := 0 to CustomHeaders.Count - 1 do
    Env.OutHeader((CustomHeaders.Names[i]), (CustomHeaders.Values[CustomHeaders.Names[i]]));
  if ContentType = '' then
  begin
    ContentType := 'charset=' + ContentEncoding;
  end
  else if Pos('charset', ContentType) < 0 then
  begin
    ContentType := ContentType + '; charset=' + ContentEncoding;
  end;
  date := UTF8ToString(NowUTCToString());
  env.OutHeader('Date', date);
  env.Context.Status := StatusCode;
  Env.FContext.OutContentType := StringToUTF8(ContentType);
end;

procedure TWebResponse.SendResponse;
begin
  if not FSent then
  begin
    FSent := true;
    SetHeadValues();
    env.Context.OutContent := StringToUTF8(content);
  end;
end;

procedure TWebResponse.SendStream(AStream: TStream);
begin
  if not FSent then
  begin
    FSent := true;
    SetHeadValues();
    Env.OutStream(AStream, ContentType);
  end;
end;

procedure TWebResponse.SetContent(const Value: WBString);
begin
  FContent := Value;
end;

procedure TWebResponse.SetContentEncoding(const Value: WBString);
begin
  FContentEncoding := Value;
end;

procedure TWebResponse.SetContentType(const Value: WBString);
begin
  FContentType := Value;
end;

procedure TWebResponse.SetCustomHeader(key, value: WBString);
begin
  Fenv.OutHeader(key, value);
end;

procedure TWebResponse.SetDate(const Value: TDateTime);
begin
  FDate := Value;
end;

procedure TWebResponse.SetStatusCode(const Value: integer);
begin
  FStatusCode := Value;
end;

{ TCookie }

procedure TCookie.AssignTo(Dest: TPersistent);
begin
  if Dest is TCookie then
    with TCookie(Dest) do
    begin
      name := Self.FName;
      value := Self.FValue;
      Domain := Self.FDomain;
      Path := Self.FPath;
      Expires := Self.FExpires;
      Secure := Self.FSecure;
      HttpOnly := Self.FHttpOnly;
      SameSite := Self.FSameSite;
    end
  else
    inherited AssignTo(Dest);
end;

constructor TCookie.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FExpires := -1;
end;

function TCookie.GetHeaderValue: WBString;
var
  S: WBString;
begin
  S := Format('%s=%s; ', [TNetEncoding.URL.Encode(FName), TNetEncoding.URL.Encode(FValue)]);
  if Domain <> '' then
    S := S + Format('domain=%s; ', [Domain]);  { do not localize }
  if Path <> '' then
    S := S + Format('path=%s; ', [Path]);      { do not localize }
  if Expires > -1 then
    S := S +
      Format(FormatDateTime('"expires="' + sDateFormat + ' "GMT; "', Expires),  { do not localize }
        [DayOfWeekStr(Expires), MonthStr(Expires)]);
  if Secure then
    S := S + 'secure; ';  { do not localize }
  if HttpOnly then
    S := S + 'httponly';  { do not localize }
  if Copy(S, Length(S) - 1, MaxInt) = '; ' then
    SetLength(S, Length(S) - 2);
  Result := S;
end;

{ TCookieCollection }

function TCookieCollection.Add: TCookie;
begin
  Result := TCookie(inherited Add);
end;

constructor TCookieCollection.Create(WebResponse: TWebResponse; ItemClass: TCollectionItemClass);
begin
  inherited Create(ItemClass);
  FWebResponse := WebResponse;
end;

function TCookieCollection.GetCookie(Index: Integer): TCookie;
begin
  Result := TCookie(inherited Items[Index]);
end;

procedure TCookieCollection.SetCookie(Index: Integer; Cookie: TCookie);
begin
  Items[Index].Assign(Cookie);
end;

destructor TWebRequest.Destroy;
begin
  if Assigned(FCookieFields) then
    FCookieFields.Free;
  if Assigned(FAbstractWebRequestFiles) then
    FAbstractWebRequestFiles.Free;
  inherited;
end;

function TWebRequest.GetAccept: WBString;
begin
  Result := FEnv.GetHeader('Accept:');
end;

function TWebRequest.GetAcceptEncoding: WBString;
begin
  Result := FEnv.GetHeader('Accept-Encoding:');
end;

function TWebRequest.GetAcceptLanguage: WBString;
begin
  Result := (FEnv.GetHeader('AcceptLanguage:'));
end;

function TWebRequest.GetConnection: WBString;
begin
  Result := (FEnv.GetHeader('Connection:'));
end;

function TWebRequest.GetContentLength: WBInt;
begin
  Result := StrToIntDef((FEnv.GetHeader('CONTENT-LENGTH:')), 0)
end;

function TWebRequest.GetCookieFields: TStrings;
var
  value, v: WBString;
  ls1: TStringList;
  i: Integer;
begin
  if not Assigned(FCookieFields) then
  begin
    FCookieFields := TStringList.Create;
    value := FEnv.GetHeader('COOKIE:');
    ls1 := TStringList.Create;
    ls1.Delimiter := ';';
    ls1.DelimitedText := value;
    for i := 0 to ls1.Count - 1 do
    begin
      v := ls1[i];
      FCookieFields.Add(v);
    end;
    ls1.Free;
  end;
  Result := FCookieFields;
end;

function TWebRequest.GetFiles: TAbstractWebRequestFiles;
begin
  Result := FAbstractWebRequestFiles;
end;

function TWebRequest.GetHeader(const AUpKey: WBString): WBString;
begin
  Result := FEnv.GetHeader(AUpKey);
end;

function TWebRequest.GetHost: WBString;
begin
  Result := (FEnv.GetHeader('Host:'));
end;

function TWebRequest.GetUserAgent: WBString;
begin
  Result := (FEnv.GetHeader('User-Agent:'));
end;

{ TAbstractWebRequestFile }

constructor TAbstractWebRequestFile.Create();
begin
end;

destructor TAbstractWebRequestFile.Destroy;
begin
  if Assigned(FStream) then
    FStream.Free;
  inherited;
end;

function TAbstractWebRequestFile.GetContentType: WBString;
begin
  Result := UTF8ToString(FAFile.ContentType);
end;

function TAbstractWebRequestFile.GetFieldName: WBString;
begin
  Result := UTF8ToString(FAFile.Name);
end;

function TAbstractWebRequestFile.GetFileName: WBString;
begin
  Result := UTF8ToString(FAFile.FileName);
end;

function TAbstractWebRequestFile.GetStream: TMemoryStream;
var
  strStream: TStringStream;
begin

  if not Assigned(FStream) then
  begin
    strStream := TStringStream.Create(FAFile.Content);
    FStream := TMemoryStream.Create;
    Fstream.Size := strStream.Size;
    FStream.CopyFrom(strStream, strStream.Size);
    strStream.Free;
  end;
  Result := FStream;
end;

procedure TAbstractWebRequestFile.SetFile(AFile: TMultiPart);
begin
  FAFile := AFile;
end;

{ TAbstractWebRequestFiles }

constructor TAbstractWebRequestFiles.Create(const AEnv: THttpApi);
var
  contenttype: WBString;
begin
  FEnv := AEnv;
  contenttype := UTF8ToString(FEnv.FContext.InContentType);
  FAbstractWebRequestFile := TAbstractWebRequestFile.Create;
  if (contenttype <> '') and (Pos('multipart/form-data', contenttype) > -1) then
    MultiPartFormDataDecode(FEnv.FContext.InContentType, FEnv.FContext.InContent, FParts);
end;

destructor TAbstractWebRequestFiles.Destroy;
begin
  FAbstractWebRequestFile.Free;
  inherited;
end;

function TAbstractWebRequestFiles.GetCount: Integer;
begin
  Result := Length(FParts);
end;

function TAbstractWebRequestFiles.GetItem(I: Integer): TAbstractWebRequestFile;
begin
  FAbstractWebRequestFile.SetFile(FParts[I]);
  Result := FAbstractWebRequestFile;
end;

end.

